Pascal Super Library/Pascal Super Library (CW International)(1997).bin/DELPHI32/LISTBOX/CHECKLB/CHECKLB.ZIP/CheckLB.pas

Pascal/Delphi Source File | 1996-08-30 | 11KB | 318 lines

{ -------------------------------------------------------------------------------------}
{ A "CheckListBox" component for Delphi32.                                             }
{ Copyright 1996, Patrick Brisacier.  All Rights Reserved.                             }
{ This component can be freely used and distributed in commercial and private          }
{ environments, provided this notice is not modified in any way.                       }
{ -------------------------------------------------------------------------------------}
{ Feel free to contact us if you have any questions, comments or suggestions at        }
{ [e-mail] (Patrick Brisacier)                                        }
{ -------------------------------------------------------------------------------------}
{ Date last modified:  08/15/96                                                        }
{ -------------------------------------------------------------------------------------}

{ -------------------------------------------------------------------------------------}
{ TCheckListBox v1.00                                                                  }
{ -------------------------------------------------------------------------------------}
{ Description:                                                                         }
{   A component that adds check property to ListBoxes items.                           }
{ Added Properties to ListBox:                                                         }
{   property Checked[Index: Integer]: Boolean;          "Run-time only property"       }
{   property State[Index: Integer]: TCheckBoxState;     "Run-time only property"       }
{   property AllowGrayed: Boolean;                                                     }
{   property Offset: Integer;                                                          }
{                                                                                      }
{ See example contained in example.zip file for more details.                          }
{ -------------------------------------------------------------------------------------}
{ Revision History:                                                                    }
{ 1.00:  + Initial release                                                             }
{ -------------------------------------------------------------------------------------}

unit CheckLB;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls;

type
  TItemState = class
  public
    Checked: Boolean;
    State: TCheckBoxState;
  end;

  TCheckListBox = class(TCustomListBox)
  private
    { DΘclarations privΘes }
    { for the bitmaps }
    FBmpChecked: TBitmap;
    FBmpGrayed: TBitmap;
    FBmpUnchecked: TBitmap;
    { for the state of every elements }
    FAllowGrayed: Boolean;
    { Offset between the listbox border and the bitmap }
    { and between the bitmap and the text              }
    FOffset: Integer;

    { Create an object associated with an item if it doesn't exist }
    procedure CreateObject(Index: Integer);

    procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
  protected
    { Set and Get functions for the properies }
    procedure SetChecked(Index: Integer; const AChecked: Boolean);
    function GetChecked(Index: Integer): Boolean;
    procedure SetState(Index: Integer; const AState: TCheckBoxState);
    function GetState(Index: Integer): TCheckBoxState;
    procedure SetOffset(AnOffset: Integer);

    procedure DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState); override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
  public
    { constructor and destructor }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    { new properties for the checkbox management }
    property Checked[Index: Integer]: Boolean
             read GetChecked write SetChecked;
    property State[Index: Integer]: TCheckBoxState
             read GetState write SetState;
  published
    { new properties for the checkbox management }
    property AllowGrayed: Boolean
             read FAllowGrayed write FAllowGrayed;
    property Offset: Integer
             read FOffset write SetOffset
             default 4;

    { pusblish the TListBox properties }
    property Align;
    property BorderStyle;
    property Color;
    property Columns;
    property Ctl3D;
    property DragCursor;
    property DragMode;
    property Enabled;
    property ExtendedSelect;
    property Font;
    property IntegralHeight;
    property ItemHeight;
    property Items;
    property MultiSelect;
    property ParentColor;
    property ParentCtl3D;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property Sorted;
    property Style default lbOwnerDrawFixed;
    property TabOrder;
    property TabWidth;
    property Visible;

    { pusblish the TListBox events }
    property OnClick;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnDrawItem;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnMeasureItem;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnStartDrag;

  end;

procedure Register;

implementation

{ include the resource file which contains the bitmaps }
{$R CheckLB.res }

constructor TCheckListBox.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  { load the bitmaps from the resource file }
  FBmpChecked := TBitmap.Create;
  FBmpChecked.LoadFromResourceName(hInstance, 'CHECKED');
  FBmpGrayed := TBitmap.Create;
  FBmpGrayed.LoadFromResourceName(hInstance, 'GRAYED');
  FBmpUnchecked := TBitmap.Create;
  FBmpUnchecked.LoadFromResourceName(hInstance, 'UNCHECKED');
  { initialize the default values }
  FOffset := 4;
  Style := lbOwnerDrawFixed;
end;

destructor TCheckListBox.Destroy;
begin
  { free the bitmaps }
  FBmpChecked.Free;
  FBmpGrayed.Free;
  FBmpUnchecked.Free;
  inherited Destroy;
end;

procedure TCheckListBox.CreateObject(Index: Integer);
var
  MyItemState: TItemState;
begin
  { check the range of Index }
  if (Index < 0) or (Index >= Items.Count) then Exit;
  if Items.Objects[Index] = nil then begin
    MyItemState := TItemState.Create;
    Items.Objects[Index] := MyItemState;
  end;
end;

procedure TCheckListBox.SetChecked(Index: Integer; const AChecked: Boolean);
begin
  { check the range of Index }
  if (Index < 0) or (Index >= Items.Count) then Exit;
  CreateObject(Index);
  if TItemState(Items.Objects[Index]).Checked <> AChecked then begin
    TItemState(Items.Objects[Index]).Checked := AChecked;
    if AChecked then
      TItemState(Items.Objects[Index]).State := cbChecked
    else
      TItemState(Items.Objects[Index]).State := cbUnchecked;
    Invalidate;
  end;
end;

function TCheckListBox.GetChecked(Index: Integer): Boolean;
begin
  { check the range of Index }
  if (Index < 0) or (Index >= Items.Count) then Exit;
  CreateObject(Index);
  Result := TItemState(Items.Objects[Index]).Checked;
end;

procedure TCheckListBox.SetState(Index: Integer; const AState: TCheckBoxState);
begin
  { check the range of Index }
  if (Index < 0) or (Index >= Items.Count) then Exit;
  CreateObject(Index);
  if TItemState(Items.Objects[Index]).State <> AState then begin
    TItemState(Items.Objects[Index]).State := AState;
    case AState of
    cbChecked:
      TItemState(Items.Objects[Index]).Checked := True;
    cbGrayed:
      TItemState(Items.Objects[Index]).Checked := False;
    cbUnchecked:
      TItemState(Items.Objects[Index]).Checked := False;
    end;
    Invalidate;
  end;
end;

function TCheckListBox.GetState(Index: Integer): TCheckBoxState;
begin
  { check the range of Index }
  if (Index < 0) or (Index >= Items.Count) then Exit;
  CreateObject(Index);
  Result := TItemState(Items.Objects[Index]).State;
end;

procedure TCheckListBox.SetOffset(AnOffset: Integer);
begin
  if FOffset <> AnOffset then begin
    FOffset := AnOffset;
    Invalidate;
  end;
end;

procedure TCheckListBox.DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState);
var
  TheBitmap: TBitmap;
  X, Y: Integer;
begin
  if Assigned(OnDrawItem) then
    OnDrawItem(Self, Index, Rect, State)
  else begin
    { calculate the right bitmap to use }
    case Self.State[Index] of
    cbChecked:
      TheBitmap := FBmpChecked;
    cbGrayed:
      TheBitmap := FBmpGrayed;
    cbUnchecked:
      TheBitmap := FBmpUnchecked;
    end;
    { draw the item }
    with Canvas do begin
      FillRect(Rect);
      X := Rect.Left + FOffset;
      Y := Rect.Top + (Rect.Bottom - Rect.Top - TheBitmap.Height) div 2;
      Draw(X, Y, TheBitmap);
      X := X + TheBitmap.Width + FOffset;
      Y := Rect.Top + (Rect.Bottom - Rect.Top - TextHeight(' ')) div 2;
      Rect.Left := X;
      TextRect(Rect, X, Y, Items[Index]);
    end;
  end;
end;

procedure TCheckListBox.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var
  Index: Integer;
  Rect: TRect;
begin
  Index := ItemAtPos(Point(X, Y), True);
  if Index <> -1 then begin
    Rect := ItemRect(Index);
    if (Button = mbLeft)
        and (X >= Rect.Left + FOffset)
        and (X < Rect.Left + FOffset + FBmpChecked.Width) then
    begin
      if FAllowGrayed then begin
        case State[Index] of
        cbChecked:
          State[Index] := cbUnchecked;
        cbGrayed:
          State[Index] := cbChecked;
        cbUnchecked:
          State[Index] := cbGrayed;
        end;
      end
      else
        Checked[Index] := not Checked[Index];
      Invalidate;
    end;
  end;
  inherited;
end;

procedure TCheckListBox.CMFontChanged(var Message: TMessage);
var
  BitmapHeight, FontHeight: Integer;
begin
  inherited;
  Canvas.Font := Font;
  BitmapHeight := FBmpChecked.Height;
  FontHeight := Canvas.TextHeight(' ');
  if FontHeight > BitmapHeight then
    ItemHeight := FontHeight
  else
    ItemHeight := BitmapHeight;
end;

procedure Register;
begin
  RegisterComponents('SystΦme', [TCheckListBox]);
end;

end.